home *** CD-ROM | disk | FTP | other *** search
/ CU Amiga Super CD-ROM 27 / CU Amiga Magazine's Super CD-ROM 27 (1998)(EMAP Images)(GB)[!][issue 1998-10].iso / CUCD / Programming / JForth / Extras / SysGen / strings < prev    next >
Encoding:
Text File  |  1991-10-24  |  2.2 KB  |  98 lines

  1. \ Support for text strings
  2. \
  3. \ Copyright 1988 - Delta Research
  4. \ All Rights Reserved
  5.  
  6. \ MOD: PLB 10/1/87 Fix stack in (?WARNING")
  7. \ MOD: PLB 7/28/88 General cleanup.
  8. \ MOD: PLB 8/16/88 Make ABORT" call ABORT instead of QUIT
  9. \ MOD: PLB 8/31/90 Added ,"
  10.  
  11. decimal
  12.  
  13. max-inline @  20 max-inline !
  14.  
  15. : COMPILING?  ( --- FLAG )
  16.     state @ both ;
  17.  
  18. : INTERPRETING? ( --- FLAG )
  19.     state @ 0= both ;
  20.  
  21. max-inline !
  22. \ : lword  ( char -- addr , accept lower case )
  23. \   makeucase @ >r  0 makeucase !
  24. \   word        r>    makeucase !  ;
  25.  
  26. : ASCII  ( --- CHAR )  ( TEST --IN-- )
  27.     bl lword 1+ c@ 
  28.     compiling? IF  [] LITERAL 
  29.                THEN ; IMMEDIATE
  30.  
  31. : $TYPE   ( addr-- )
  32.     count type  ;
  33.  
  34. : $SIZE  ( $ADR --- TOTAL-ALLOTED-TO-$ )
  35.     c@ 1+ even-up both ;
  36.  
  37. : $,   ( delim--<word> ,  compile input-string into dict )
  38.     lword    $size  allot    ;
  39.  
  40. : ,"  ( <string>" -- , lay down at HERE, allot space )
  41.     ascii " lword
  42.     c@ 1+ allot align
  43. ;
  44.  
  45. : TYPE-HERE ( --- )
  46.     here $type ;
  47.  
  48. : $MOVE  ( from to --- )
  49.     over c@ 1+ move ;
  50.  
  51. : >$   ( adr cnt $adr -- , move text for cnt into counted string at $adr )
  52.   2dup c!        \ plug in count
  53.   1+ swap move   \ add the text after it
  54. ;
  55.  
  56. : (($"))      ( string RADDR --r-- RADDR next-ip ) 
  57.       r>  inline@ dup  $size
  58.       inline+  swap  >r    ;
  59.  
  60. : ($")   ( --adr )  ( string-adr  --INLINE-- NEXT-IP )  
  61.    (($"))   ;  ( must be called ) 
  62.  
  63. \ : (.")   ( --- )  ( $ --IN-- )  (($")) $TYPE ; ( in kernal ) 
  64.  
  65. : ." ( --- )
  66.     ASCII "    compiling? 
  67.     IF    compile (.")  $,
  68.     ELSE  lword $type
  69.     THEN  ; immediate
  70.  
  71. : $"   ( -- adr )
  72.     compile ($")   ascii "  $,    ; IMMEDIATE
  73.  
  74. : (?WARNING")  ( FLAG --- )  ( <STRING> -INLINE- )
  75.     (($"))  swap
  76.     IF    >newline dup $type
  77.     THEN  drop  ;
  78.  
  79. : WARNING"  ( flag --- )  ( <"> <TEXT> -IN- ) 
  80.      compile  (?warning")  ascii " $,  ; IMMEDIATE
  81.  
  82. : (?ABORT")  ( FLAG --- )  ( <STRING> -INLINE- )
  83.     (($"))  swap
  84.     IF    >newline $type abort 
  85.     THEN  drop  ;
  86.  
  87. : ABORT"  ( flag --- )  ( <"> <TEXT> -IN- ) 
  88.      compile  (?abort")  ascii " $,  ; IMMEDIATE
  89.  
  90. : ?ABORT"  [] abort"  ; IMMEDIATE 
  91.  
  92. \ INCLUDE STRINGS.TEST
  93. \ all functions tested sept 9 '86. BTD
  94.  
  95. \ ($LIT) has been renamed to (($")) to emphasize it's relation to ($")
  96.  
  97.  
  98.